home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / BBS-Archive / Dev / Obrn-A_1.6_lib.lha / oberon-a / source3.lha / source / Library / BufIO.mod < prev    next >
Text File  |  1995-01-25  |  11KB  |  371 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: BufIO.mod $
  4.   Description: Simple formatted I/O using the standard input and output
  5.                handles.
  6.  
  7.    Created by: fjc (Frank Copeland)
  8.     $Revision: 1.1 $
  9.       $Author: fjc $
  10.         $Date: 1995/01/26 00:40:27 $
  11.  
  12.   Copyright © 1994, Frank Copeland.
  13.   This file is part of the Oberon-A Library.
  14.   See Oberon-A.doc for conditions of use and distribution.
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. ***************************************************************************)
  19.  
  20. <* STANDARD- *>
  21.  
  22. MODULE BufIO;
  23.  
  24. IMPORT  SYSTEM, Dos, Reals, WbConsole;
  25.  
  26. CONST   maxD = 9;
  27.  
  28. VAR     W, R: Dos.FileHandlePtr;
  29.  
  30.  
  31. PROCEDURE Write* (fh: Dos.FileHandlePtr; ch: CHAR);
  32. BEGIN
  33.         IF fh = NIL THEN fh := W END;
  34.         IF Dos.FPutC (fh, ORD (ch)) = -1 THEN (* Error *) END
  35. END Write;
  36.  
  37.  
  38. PROCEDURE WriteLn* (fh: Dos.FileHandlePtr);
  39. BEGIN
  40.         Write (fh, "\n")
  41. END WriteLn;
  42.  
  43.  
  44. <*$CopyArrays-*>
  45. PROCEDURE WriteStr* (fh: Dos.FileHandlePtr; str: ARRAY OF CHAR);
  46. BEGIN
  47.         IF fh = NIL THEN fh := W END;
  48.         IF Dos.FPuts (fh, str) THEN (* Error *) END
  49. END WriteStr;
  50.  
  51.  
  52. <*$CopyArrays-*>
  53. PROCEDURE WriteF* (fh: Dos.FileHandlePtr; fs : ARRAY OF CHAR; VAR f : ARRAY OF SYSTEM.LONGWORD);
  54. BEGIN
  55.         IF fh = NIL THEN fh := W END;
  56.         IF Dos.VFPrintf (fh, fs, f) = -1 THEN (* Error *) END
  57. END WriteF;
  58.  
  59.  
  60. <*$CopyArrays-*>
  61. PROCEDURE WriteF1* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR; p1 : SYSTEM.LONGWORD);
  62. BEGIN
  63.         IF fh = NIL THEN fh := W END;
  64.         IF Dos.FPrintf (fh, fs, p1) = -1 THEN (* Error *) END
  65. END WriteF1;
  66.  
  67.  
  68. <*$CopyArrays-*>
  69. PROCEDURE WriteF2* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
  70.                     p1, p2: SYSTEM.LONGWORD);
  71. BEGIN
  72.         IF fh = NIL THEN fh := W END;
  73.         IF Dos.FPrintf (fh, fs, p1, p2) = -1 THEN (* Error *) END
  74. END WriteF2;
  75.  
  76.  
  77. <*$CopyArrays-*>
  78. PROCEDURE WriteF3* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
  79.                     p1, p2, p3: SYSTEM.LONGWORD);
  80. BEGIN
  81.         IF fh = NIL THEN fh := W END;
  82.         IF Dos.FPrintf (fh, fs, p1, p2, p3) = -1 THEN (* Error *) END
  83. END WriteF3;
  84.  
  85.  
  86. <*$CopyArrays-*>
  87. PROCEDURE WriteF4* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
  88.                     p1, p2, p3, p4: SYSTEM.LONGWORD);
  89. BEGIN
  90.         IF fh = NIL THEN fh := W END;
  91.         IF Dos.FPrintf (fh, fs, p1, p2, p3, p4) = -1 THEN (* Error *) END
  92. END WriteF4;
  93.  
  94.  
  95. <*$CopyArrays-*>
  96. PROCEDURE WriteF6* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
  97.                     p1, p2, p3, p4, p5, p6: SYSTEM.LONGWORD);
  98. BEGIN
  99.         IF fh = NIL THEN fh := W END;
  100.         IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6) = -1 THEN (* Error *) END
  101. END WriteF6;
  102.  
  103.  
  104. <*$CopyArrays-*>
  105. PROCEDURE WriteF7* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
  106.                     p1, p2, p3, p4, p5, p6, p7: SYSTEM.LONGWORD);
  107. BEGIN
  108.         IF fh = NIL THEN fh := W END;
  109.         IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7) = -1 THEN (* Error *) END
  110. END WriteF7;
  111.  
  112.  
  113. <*$CopyArrays-*>
  114. PROCEDURE WriteF8* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
  115.                     p1, p2, p3, p4, p5, p6, p7, p8: SYSTEM.LONGWORD);
  116. BEGIN
  117.         IF fh = NIL THEN fh := W END;
  118.         IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8) = -1 THEN (* Error *) END
  119. END WriteF8;
  120.  
  121.  
  122. <*$CopyArrays-*>
  123. PROCEDURE WriteF9* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
  124.                     p1, p2, p3, p4, p5, p6, p7, p8, p9: SYSTEM.LONGWORD);
  125. BEGIN
  126.         IF fh = NIL THEN fh := W END;
  127.         IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8, p9) = -1 THEN (* Error *) END
  128. END WriteF9;
  129.  
  130.  
  131. <*$CopyArrays-*>
  132. PROCEDURE WriteF10* (fh: Dos.FileHandlePtr; fs: ARRAY OF CHAR;
  133.                     p1, p2, p3, p4, p5, p6, p7, p8, p9, p10: SYSTEM.LONGWORD);
  134. BEGIN
  135.         IF fh = NIL THEN fh := W END;
  136.         IF Dos.FPrintf (fh, fs, p1, p2, p3, p4, p5, p6, p7, p8, p9, p10) = -1 THEN (* Error *) END
  137. END WriteF10;
  138.  
  139.  
  140. PROCEDURE WriteInt* (fh: Dos.FileHandlePtr; i: LONGINT);
  141. BEGIN
  142.         WriteF1 (fh, "%ld", i)
  143. END WriteInt;
  144.  
  145.  
  146. PROCEDURE WriteHex* (fh: Dos.FileHandlePtr; i : LONGINT);
  147. BEGIN
  148.         WriteF1 (fh, "%lx", i)
  149. END WriteHex;
  150.  
  151.  
  152. (*
  153.  * The following WriteReal* and WriteLongReal* procedures have been pinched
  154.  * from Module Texts and have been somewhat modified from the original code
  155.  * described in "Project Oberon".
  156.  *)
  157.  
  158. PROCEDURE WriteReal* (fh: Dos.FileHandlePtr; x: REAL; n: INTEGER );
  159. VAR     e : INTEGER;
  160.         x0: REAL;
  161.         d : ARRAY maxD OF CHAR;
  162. BEGIN
  163.         (*
  164.          * This implementation uses Motorola FFP format reals instead of IEEE
  165.          * single-precision reals.  The Project Oberon code has been modified to
  166.          * remove the special-case handling of unnormal and NaN values and assume
  167.          * 7-bit exponents instead of 8-bit.
  168.          *)
  169.         e := Reals.Expo (x);
  170.         IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
  171.         REPEAT Write (fh, " "); DEC (n) UNTIL n <= 8;
  172.         (* there are 2 < n <= 8 digits to be written *)
  173.         IF x < 0.0 THEN Write (fh, "-"); x := -x ELSE Write (fh, " ") END;
  174.         e := (e - 64) * 77 DIV 256;
  175.         IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  176.         IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  177.         x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  178.         IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  179.         Reals.Convert (x, n, d);
  180.         DEC (n); Write (fh, d [n]); Write (fh, ".");
  181.         REPEAT DEC (n); Write (fh, d [n]) UNTIL n = 0;
  182.         Write (fh, "E");
  183.         IF e < 0 THEN Write (fh, "-"); e := -e ELSE Write (fh, "+") END;
  184.         Write (fh, CHR (e DIV 10 + 30H)); Write (fh, CHR (e MOD 10 + 30H))
  185. END WriteReal;
  186.  
  187.  
  188. PROCEDURE WriteRealFix* (fh: Dos.FileHandlePtr; x: REAL; n, k: INTEGER);
  189. VAR     e, i: INTEGER;
  190.         sign: CHAR;
  191.         x0: REAL;
  192.         d : ARRAY maxD OF CHAR;
  193.  
  194.         PROCEDURE seq (ch: CHAR; n: LONGINT);
  195.         BEGIN
  196.                 WHILE n > 0 DO Write (fh, ch); DEC (n) END
  197.         END seq;
  198.  
  199.         PROCEDURE dig (n : INTEGER);
  200.         BEGIN
  201.                 WHILE n > 0 DO
  202.                         DEC (i); Write (fh, d [i]); DEC (n)
  203.                 END;
  204.         END dig;
  205.  
  206. BEGIN   (*
  207.          * This implementation uses Motorola FFP format reals instead of IEEE
  208.          * single-precision reals.  The Project Oberon code has been modified to
  209.          * remove the special-case handling of unnormal and NaN values and assume
  210.          * 7-bit exponents instead of 8-bit.
  211.          *)
  212.         IF k < 0 THEN k := 0 END;
  213.         e := (Reals.Expo (x) - 64) * 77 DIV 256;
  214.         IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
  215.         IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
  216.         ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x END;
  217.         IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  218.         (* 1 <= x < 10 *)
  219.         IF k + e >= maxD - 1 THEN k := maxD - 1 - e
  220.         ELSIF k + e < 0 THEN k := -e; x := 0.0
  221.         END;
  222.         x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
  223.         IF x >= 10.0 * x0 THEN INC (e) END;
  224.         (* e = no. of digits before decimal point *)
  225.         INC (e); i := k + e; Reals.Convert (x, i, d);
  226.         IF e > 0 THEN
  227.                 seq (" ", n - e - k - 2); Write (fh, sign); dig (e); Write (fh, ".");
  228.                 dig (k)
  229.         ELSE
  230.                 seq (" ", n - k - 3); Write (fh, sign); Write (fh, "0"); Write (fh, ".");
  231.                 seq ("0", -e); dig (k + e)
  232.         END; (* ELSE *)
  233. END WriteRealFix;
  234.  
  235.  
  236. PROCEDURE WriteRealHex* (fh: Dos.FileHandlePtr; x: REAL);
  237. VAR     d : ARRAY 9 OF CHAR;
  238. BEGIN
  239.         Reals.ConvertH (x, d); d [8] := 0X; WriteStr (fh, d)
  240. END WriteRealHex;
  241.  
  242.  
  243. PROCEDURE WriteLongReal* (fh: Dos.FileHandlePtr; x: LONGREAL; n: INTEGER);
  244. BEGIN
  245.         (*
  246.          * In this implementation, LONGREAL and REAL types are the same, so this
  247.          * procedure is implemented as a call to WriteReal ().
  248.          *)
  249.         WriteReal (fh, SHORT (x), n)
  250. END WriteLongReal;
  251.  
  252.  
  253. PROCEDURE WriteLongRealHex* (fh: Dos.FileHandlePtr; x: LONGREAL);
  254. BEGIN
  255.         (*
  256.          * In this implementation, LONGREAL and REAL types are the same, so this
  257.          * procedure is implemented as a call to WriteRealHex ().
  258.          *)
  259.         WriteRealHex (fh, SHORT (x))
  260. END WriteLongRealHex;
  261.  
  262.  
  263. PROCEDURE Read* (fh: Dos.FileHandlePtr; VAR ch : CHAR);
  264. VAR     i: LONGINT;
  265. BEGIN
  266.         IF fh = NIL THEN fh := R END;
  267.         i := Dos.FGetC (fh);
  268.         IF i = -1 THEN
  269.                 ch := 0X
  270.         ELSE    ch := CHR (SHORT (SHORT (i)))
  271.         END
  272. END Read;
  273.  
  274.  
  275. PROCEDURE ReadStr* (fh: Dos.FileHandlePtr; VAR str : ARRAY OF CHAR);
  276. VAR     ch: CHAR;
  277.         index, limit: INTEGER;
  278. BEGIN
  279.         (* Skip white space *)
  280.         REPEAT Read (fh, ch) UNTIL (ch # " ") & (ch # 09X);
  281.         (* Read until control char *)
  282.         index := 0; limit := SHORT (LEN (str));
  283.         WHILE (ch >= " ") & (index < limit) DO
  284.                 str [index] := ch; INC (index); Read (fh, ch);
  285.         END; (* WHILE *)
  286.         str [index] := 0X;
  287.         (* Skip rest of line if any *)
  288.         WHILE ch >= " " DO Read (fh, ch) END
  289. END ReadStr;
  290.  
  291.  
  292. PROCEDURE ReadHexDigit (fh: Dos.FileHandlePtr; i: INTEGER): BOOLEAN;
  293. VAR     ch: CHAR;
  294. BEGIN
  295.         Read (fh, ch);
  296.         ch := CAP (ch);
  297.         IF ("0" <= ch) & (ch <= "9") THEN
  298.                 i := ORD (ch) - ORD ("0")
  299.         ELSIF ("A" <= ch) & (ch <= "F") THEN
  300.                 i := ORD (ch) - ORD ("A") + 10
  301.         ELSE
  302.                 i := 0;
  303.                 IF Dos.UnGetC (fh, -1) = -1 THEN (* Error *) END;
  304.                 RETURN FALSE    (* error *)
  305.         END;
  306.         RETURN TRUE             (* success *)
  307. END ReadHexDigit;
  308.  
  309.  
  310. PROCEDURE ReadShortHex* (fh: Dos.FileHandlePtr; VAR i: SHORTINT): BOOLEAN;
  311. VAR     n, j: INTEGER;
  312. BEGIN
  313.         i := 0;
  314.         FOR n := 1 TO 2 DO
  315.                 IF ReadHexDigit (fh, j) THEN
  316.                         i := i*16 + SHORT (j)
  317.                 ELSE    IF n > 1 THEN
  318.                                 RETURN TRUE
  319.                         ELSE
  320.                                 RETURN FALSE    (* error *)
  321.                         END
  322.                 END
  323.         END;
  324.         RETURN TRUE                     (* success *)
  325. END ReadShortHex;
  326.  
  327.  
  328. PROCEDURE ReadHex* (fh: Dos.FileHandlePtr; VAR i: INTEGER): BOOLEAN;
  329. VAR     n, j: INTEGER;
  330. BEGIN
  331.         i := 0;
  332.         FOR n := 1 TO 4 DO
  333.                 IF ReadHexDigit (fh, j) THEN
  334.                         i := i*16 + j
  335.                 ELSE    IF n > 1 THEN
  336.                                 RETURN TRUE
  337.                         ELSE
  338.                                 RETURN FALSE    (* error *)
  339.                         END
  340.                 END
  341.         END;
  342.         RETURN TRUE                     (* success *)
  343. END ReadHex;
  344.  
  345.  
  346. PROCEDURE ReadLongHex* (fh: Dos.FileHandlePtr; VAR i: LONGINT): BOOLEAN;
  347. VAR     n, j: INTEGER;
  348. BEGIN
  349.         i := 0;
  350.         FOR n := 1 TO 8 DO
  351.                 IF ReadHexDigit (fh, j) THEN
  352.                         i := i*16 + j
  353.                 ELSE    IF n > 1 THEN
  354.                                 RETURN TRUE
  355.                         ELSE
  356.                                 RETURN FALSE    (* error *)
  357.                         END
  358.                 END
  359.         END;
  360.         RETURN TRUE                     (* success *)
  361. END ReadLongHex;
  362.  
  363.  
  364. BEGIN   IF Dos.base.lib.version < 37 THEN
  365.                 SYSTEM.SETREG (0, Dos.Write (Dos.Output(), "Requires AmigaDOS version 2 or later.\n", 40));
  366.                 HALT (Dos.fail)
  367.         END;
  368.         W := Dos.Output ();
  369.         R := Dos.Input ()
  370. END BufIO.
  371.